home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / der12.zip / DER.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  33KB  |  1,192 lines
  1. {$B-,D-,T-,I-,L-,S-,V-}
  2. { --------------------------------------------------------------------------- }
  3. {  A unit providing a set of tested data entry routines.
  4.  
  5.   Version 1.20 - 05/05/1988
  6.  
  7.   Juan M. Vegarra
  8.   I.C.U. Research Unit, George Washington University Medical Center.
  9.   2300 K. St, N.W.
  10.   Washington, D.C. 20037
  11.   <Work Phone> (202) 994-2614    <Home Phone> (703) 379-7334
  12.   Compuserve 72770,247
  13.  
  14.  
  15. { --------------------------------------------------------------------------- }
  16.  
  17. Unit DER; { Data Entry Routines }
  18.  
  19. Interface
  20. Uses
  21.   Crt,
  22.   Dos,
  23.   Dates,   { Scott Bussinger's Dates unit from CIS BORPRO DL2 }
  24.   QWIK,    { Jim LeMay's QWIK41A unit from CIS BORPRO DL2 }
  25.   WNDWVars,
  26.   WNDW;    { Jim LeMay's WNDW40  unit from CIS BORPRO DL2 }
  27.  
  28. Const
  29.   CursorLeft  = ^S;   { WordStar and Turbo Editor Keys }
  30.   CursorRight = ^D;
  31.   CursorDown  = ^X;
  32.   CursorUp    = ^E;
  33.   CursorHome  = ^A;
  34.   CursorEnd   = ^F;
  35.   PageUp      = ^R;
  36.   PageDown    = ^C;
  37.   DelKey      = ^G;
  38.   TabKey      = #9;
  39.   PlusKey     = '+'; { Use to Set Bit in Multiple Choice }
  40.   MinusKey    = '-'; { Use to Clear Bit in Multiple Choice }
  41.   Return      = ^M;
  42.   Escape      = ^[;
  43.   HelpKey     = #59; { F1 Key }
  44.   UpperCase   : Boolean = False;
  45.   ExtKey      : Boolean = False;
  46.   Filler      : Char =  #32; {#250;}
  47.   AutoWrap    : Boolean = False;
  48.  
  49. Type
  50.   Str2 = String[2];  { FOR CIS only use str2 str8 }
  51.   Str4 = String[4];
  52.   Str5 = String[5];
  53.   Str6 = String[6];
  54.   Str8 = String[8];
  55.   Str10 = String[10];
  56.   Str15 = String[15];
  57.   Str20 = String[20];
  58.   Str60 = String[60];
  59.   Str80 = String[80];
  60.   Str132 = String[132];
  61.   CharSet = Set of Char;
  62.   ByteSet = Set of Byte;
  63.  
  64.   Time       = Record
  65.                  Hour  : Byte;
  66.                  Minute: Byte;
  67.                End;
  68.  
  69.   Phone      = Record
  70.                  Area    : Word;
  71.                  XChange : Word;
  72.                  Number  : Word;
  73.                End;
  74.  
  75.   SSN        = Record
  76.                  First  : Word; { 000..999   }
  77.                  Middle : Word; { 00..99     }
  78.                  Last   : Word; { 0000..9999 }
  79.                End;
  80.  
  81. Var
  82.   OLDCursor  : Word;
  83.   NormalAtt  : Byte;
  84.   ReverseAtt : Byte;
  85.  
  86. Function  UnPack(Param,No:Byte):String;
  87. { Returns a binary string of length = No in reverse order
  88.   Example: Str := UnPack(56,6);  ==> Str := 000111
  89.   I use this function to unpack a multiple choice response field }
  90.  
  91. Procedure Pad_With_Blanks(Var Target:String;Len:Byte);
  92. { Right Pads Target with ' ' }
  93.  
  94. Procedure BlankToZero(Var Temp:String;Place:Byte);
  95. { Replaces ' ' with '0' in Target }
  96.  
  97. { Left Pad Target with zeros
  98.   Example: if target = 12 and Str := LeftPad_Word(Target,5) Then
  99.            Str := '00012'
  100.  }
  101. Function  LeftPad_Long(Target:LongInt;Len:Byte):String;
  102. Function  LeftPad_Byte(Target,Len:Byte):String;
  103. Function  LeftPad_Word(Target:Word;Len:Byte):String;
  104. Function  LeftPad_Integer(Target:Integer;Len:Byte):String;
  105.  
  106. Procedure CheckLimit(Var L:Byte;TC:Char;Up,Down:CharSet;LL,HL:Byte);
  107. { Selects next question in data entry screen }
  108.  
  109. Procedure CheckCursor;
  110. { This procedure was copied from Jim LeMay's QWIK40 documentation }
  111.  
  112. Procedure Beep;
  113. { Generate Error sound }
  114.  
  115. Function  UpcaseStr(S : String) : String;
  116. { Returns the UpperCase version of S }
  117.  
  118. Procedure Today(Var Date1: Date);
  119. { Returns Today's date in MM/DD/YY format }
  120.  
  121. { These four functions could be used with the database toolbox
  122.   whenever you use numbers as keys }
  123. Function  WordToStr(ID  : Word):Str2;
  124. Function  IntToStr (ID  : Integer):Str2;
  125. Function  StrToWord(Key : Str2):Word;
  126. Function  StrToInt (Key : Str2):Integer;
  127.  
  128. { The following group of functions need no explanation, with the exception
  129.   of BooleanToString.  In all my medical applications I need to keep track
  130.   of missing values, therefore I created a pseudo boolean variable:
  131.   0 : Missing;  1 : True;  2 : False.
  132.   You can use this function to store a bunch of dichotomous variables
  133.   Example: (Sex,'M','F') or (YesNo,'Y','N') or (TrueFalse,'T','F') }
  134.  
  135. Function  LongIntToString(Param : LongInt): String;
  136. Function  IntegerToString(Param : Integer): String;
  137. Function  WordToString(Param : Word): String;
  138. Function  ByteToString(Param : Byte): String;
  139. Function  BooleanToString(Param : Byte;IfTrue,IfFalse : Char): String;
  140. Function  RealToString(Param : Real): String;
  141.  
  142. Function  AddStrings(S2,S3 : String):String;
  143. { Returns AddStrings := S2 + S3; }
  144.  
  145. Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);
  146. Function  ReadChar : Char;
  147. Function  ConstStr(C : Char; N : Byte) : String;
  148. { Returns a string of N C's }
  149.  
  150. Function  AskStr(Var S:String;Term:CharSet;L,X,Y:Byte;Var TC:Char):String;
  151. { This function allows you to move left, right, home , end, delete, etc
  152.   in any data entry field.  It automatically wraps to the next data entry
  153.   field, once the limit 'L' has been reached }
  154.  
  155. { The following group of functions allow you to enter: strings, booleans,
  156.   words, integers, bytes, etc. with range checking, and field length }
  157. Function  SelectString(Var Param : String; Len, X, Y : Byte) : Char;
  158. Function  SelectBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;
  159. Function  SelectLongInt(Var Param:LongInt;Lower,Upper:LongInt;Len,X,Y:Byte):Char;
  160. Function  SelectWord(Var Param:Word;Lower,Upper:Word;Len,X,Y:Byte):Char;
  161. Function  SelectByte(Var Param:Byte;Lower,Upper,Len,X,Y:Byte):Char;
  162. Function  SelectInteger(Var Param:Integer;Lower,Upper:Integer;Len,X,Y:Byte):Char;
  163. Function  SelectReal(Var Param:Real;Lower,Upper:Real;Len,X,Y:Word):Char;
  164. Function  PhoneToString(Param:Phone):String;
  165. Function  SelectPhone(Var Param : Phone; Col,Row: Byte) : Char;
  166. Function  TimeToString(Param:Time) :String;
  167. Function  SelectTime(Var Param : Time; Col,Row: Byte) : Char;
  168.  
  169. { If you have applications that require the user to select N options from
  170.   a list of M options (N <= M <= 8) then these routines will allow you to
  171.   pack upto 8 responses into a single byte.
  172.   Example: Record ALL mentioned: [1] Alternative A
  173.                                  [2] Alternative B
  174.                                        ...
  175.                                  [8] Alternative H
  176.   See Demo for a possible use of these routines }
  177. Procedure SetBit(Var Param: Byte;BitNum : Byte);
  178. Procedure ClearBit(Var Param: Byte;BitNum : Byte);
  179. Function  Power(Pos : Byte) : Byte;
  180. Procedure ShowMultipleChoice(Param,Bit:Byte;RowOffset,ColOffset:ShortInt);
  181. Function  SelectMultiple(Var Param:Byte;From,Limit,X,Y:ShortInt):Char;
  182.  
  183. { Some Date arithmetic using Scott's DATES Unit }
  184. Function  DateToYear(Julian: Date) : Integer;
  185. Function  DateToMonth(Julian: Date) : Integer;
  186. Function  DateToDay(Julian: Date) : Integer;
  187. Function  DateToStr(Date1:Date):Str8;
  188. Procedure DisplayDate(Date1:Date;X,Y:Byte);
  189. Procedure DisplayNewDate(Date1:Date;X,Y:Byte);
  190. Function  SelectDate(Var Date1:Date;X,Y:Byte): Char;
  191. Function  DaysBtWn(Date1,Date2:Date):Word;
  192. Function  AddDays(Date1:Date;Num:Integer):Date;
  193. Function  AddMonths(Date1:Date;Num:Integer):Date;
  194.  
  195. { if you ever need to check for an answer to be in a range, here's some help.
  196.   Example: Assume you allow the answer to be a number in [1..5,8], then you
  197.   can Repeat
  198.         Ch := SelectByte(Param,1,8,1,WhereX,WhereY);
  199.       Until ByteInRange(Param,[1..5,8]); }
  200.  
  201. Function  ByteInRange(Var Param:Byte;Test:ByteSet):Boolean;
  202. Function  WordInRange(Var Param:Word;Min,Max:Word):Boolean;
  203.  
  204. Function  SSNToString(Param:SSN) : String;
  205. Function  SelectSSN(Var Param:SSN;X,Y:Byte):Char;
  206.  
  207. { New routines }
  208. Function  ColorSelect(RR,CC,DR,DC : Byte) : Byte;
  209. Procedure Wait(On : Boolean);
  210. Function  AreYouSure : Boolean;
  211. Function  SureToDelete(ID : Word) : Boolean;
  212.  
  213. { Fast checking routine, do not require you
  214.   to open any file to check for existency }
  215. Function  FileExist(FileName : String) : Boolean;
  216. Function  DirExist(DirName : String) : Boolean;
  217.  
  218. Function  CopyFile(Source, Dest : String) : Word;
  219. { CopyFile is much better than FCOPY4.ARC. Extensive IO checking.
  220.   If CopyFile fails then Dest is automatically erased }
  221.  
  222. Implementation
  223.  
  224. Function UnPack(Param,No:Byte):String;
  225. Var
  226.   I,N : Word;
  227. Begin
  228.   N := No;
  229.   UnPack[0] := Chr(No);
  230.   For I := Pred(No) downto 0 do
  231.   Begin
  232.     If (Param AND (1 shl I) <> 0) Then UnPack[N] := '1'
  233.     Else UnPack[N] := '0';
  234.     Dec(N);
  235.   End;
  236. End;
  237.  
  238. Procedure Pad_With_Blanks(Var Target:String;Len:Byte);
  239. Var
  240.   I : Word;
  241.   Actual_Length : Word;
  242.   Temp : String;
  243. Begin
  244.   Temp := Target;
  245.   Actual_Length := Length(Temp);
  246.   If Actual_Length < Len Then
  247.      For I := Actual_Length to Len Do Temp := Temp + ' ';
  248.   Temp[0] := Chr(Len);
  249.   Target := Temp;
  250. End;
  251.  
  252. Procedure BlankToZero(Var Temp:String;Place:Byte);
  253. Begin
  254.   If Temp[Place] = ' ' Then Temp[Place] := '0';
  255. End;
  256.  
  257. Function LeftPad_Long(Target:LongInt;Len:Byte):String;
  258. Var
  259.   I : Word;
  260.   Temp : String;
  261. Begin
  262.   Str(Target:Len,Temp);
  263.   For I := 1 to Length(Temp) Do BlankToZero(Temp,I);
  264.   Temp[0] := Chr(Len);
  265.   LeftPad_Long := Temp;
  266. End;
  267.  
  268. Function LeftPad_Byte(Target,Len:Byte):String;
  269. Var
  270.   I : LongInt;
  271.   Temp : String;
  272. Begin
  273.   I := LongInt(Target);
  274.   LeftPad_Byte := LeftPad_Long(I,Len);
  275. End;
  276.  
  277. Function LeftPad_Word(Target:Word;Len:Byte):String;
  278. Var
  279.   I : LongInt;
  280.   Temp : String;
  281. Begin
  282.   I := LongInt(Target);
  283.   LeftPad_Word := LeftPad_Long(I,Len);
  284. End;
  285.  
  286. Function LeftPad_Integer(Target:Integer;Len:Byte):String;
  287. Var
  288.   I : LongInt;
  289.   Temp : String;
  290. Begin
  291.   I := LongInt(Target);
  292.   LeftPad_Integer := LeftPad_Long(I,Len);
  293. End;
  294.  
  295. Procedure CheckLimit(Var L:Byte;TC:Char;Up,Down:CharSet;LL,HL:Byte);
  296. { LL = Low Limit,  HL = High Limit }
  297. Begin
  298.   If (TC In Down) Then
  299.      If L = HL Then L := LL
  300.      Else Inc(L)
  301.   Else
  302.      If (TC In Up) Then
  303.         If L = LL Then L := HL
  304.         Else Dec(L)
  305. End;
  306.  
  307. Procedure CheckCursor;
  308. { This procedure was copied from Jim LeMay's QWIK40 documentation }
  309. Var
  310.   CursorMode : Integer Absolute $0040:$0060;
  311. Begin
  312.   If ActiveDispDev = MdaMono Then
  313.      If CursorMode = $0607 Then CursorChange($0B0C,OldCursor);
  314. End;
  315.  
  316. Procedure Beep;
  317. Begin
  318.   Sound(1500); Delay(50);
  319.   Sound(1000); Delay(50);
  320.   NoSound;
  321. End;
  322.  
  323. Function UpcaseStr(S : String) : String;
  324. Var
  325.   I : Word;
  326. Begin
  327.   For I := 1 to Length(S) Do S[I] := Upcase(S[I]);
  328.   UpcaseStr := S;
  329. End;
  330.  
  331. Procedure Today(Var Date1: Date);
  332. Var
  333.   DosRegs : Registers;
  334.   Day,Month,Year : Integer;
  335. Begin
  336.   With DosRegs do
  337.   Begin
  338.     AX := $2A00;
  339.     INTR($21,DosRegs);
  340.     Day   := LO(DX);
  341.     Month := HI(DX);
  342.     Year  := CX;
  343.     DMYtoDate(Day,Month,Year,Date1);
  344.   End;
  345. End;
  346.  
  347. Function WordToStr(ID : Word):Str2;
  348. Begin
  349.   WordToStr := Chr(Hi(ID)) + Chr(Lo(ID));
  350. End;
  351.  
  352. Function IntToStr(ID : Integer):Str2;
  353. Begin
  354.   IntToStr := Chr(Hi(ID)) + Chr(Lo(ID));
  355. End;
  356.  
  357. Function StrToWord(Key : Str2):Word;
  358. Begin
  359.   StrToWord := Swap(Ord(Key[1])) + Ord(Key[2]);
  360. End;
  361.  
  362. Function  StrToInt(Key : Str2):Integer;
  363. Begin
  364.   StrToInt := Swap(Ord(Key[1])) + Ord(Key[2]);
  365. End;
  366.  
  367. Function LongIntToString(Param : LongInt): String;
  368. Var
  369.   Temp : String;
  370. BEGIN
  371.   Temp[0] := #0;
  372.   REPEAT
  373.     Temp := Chr(Param Mod 10+48)+Temp;
  374.     Param := Param Div 10;
  375.   UNTIL Param = 0;
  376.   LongIntToString := Temp;
  377. END;
  378.  
  379. Function IntegerToString(Param : Integer): String;
  380. Var
  381.   Temp : String;
  382.   WW   : LongInt;
  383. BEGIN
  384.   WW := LongInt(Param);
  385.   Temp := longIntToString(WW);
  386.   IntegerToString:=Temp;
  387. END;
  388.  
  389. Function WordToString(Param : Word): String;
  390. Var
  391.   Temp : String;
  392.   WW   : LongInt;
  393. BEGIN
  394.   WW := LongInt(Param);
  395.   Temp := longIntToString(WW);
  396.   WordToString:=Temp;
  397. END;
  398.  
  399. Function ByteToString(Param : Byte): String;
  400. Var
  401.   Temp : String;
  402.   WW   : LongInt;
  403. BEGIN
  404.   WW := LongInt(Param);
  405.   Temp := longIntToString(WW);
  406.   ByteToString:=Temp;
  407. END;
  408.  
  409. Function BooleanToString(Param : Byte;IfTrue,IfFalse : Char): String;
  410. Var
  411.   Temp : String;
  412. BEGIN
  413.   Case Param of
  414.     0: Temp := Filler;
  415.     1: Temp := IfTrue;
  416.     2: Temp := IfFalse;
  417.   End;
  418.   BooleanToString:=Temp;
  419. END;
  420.  
  421. Function RealToString(Param : Real): String;
  422. Var
  423.   Temp : String;
  424.   I    : Word;
  425. Begin
  426.   Str(Param:1:12, Temp);
  427.   I := Length(Temp);
  428.   While Temp[I] = '0' Do Dec(I);
  429.   If Temp[I] = '.' Then Dec(I);
  430.   RealToString := Copy(Temp, 1, I);
  431. End;
  432.  
  433. Function AddStrings(S2,S3 : String):String;
  434. Begin
  435.   AddStrings := S2 + S3;
  436. End;
  437.  
  438. Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);
  439. begin
  440.   ExtKey := False;
  441.   Ch := ReadKey;
  442.   If Ch = #0 Then
  443.   Begin
  444.     ExtKey := True;
  445.     Ch := ReadKey;
  446.   End;
  447. end;
  448.  
  449. Procedure ShowEditHelp;
  450. Const Help : Array[6..23] of Str80 = (
  451. 'Key Label  Key Name    Usage in Data Entry      ',
  452. '────────────────────────────────────────────────',
  453. 'F1         HELP        Provide this screen      ',
  454. ^X'          UP          Field above              ',
  455. ^Y'          DOWN        Field below              ',
  456. ^Z'          RIGHT       Next character           ',
  457. ^['          LEFT        Previous character       ',
  458. 'Home       HOME        First field in form      ',
  459. 'End        END         Last field in form       ',
  460. 'PgUp       PREV PAGE   First field on prev. page',
  461. 'PgDn       NEXT PAGE   First field on next page ',
  462. 'Backspace  BACKSPACE   Delete prev. character   ',
  463. 'Enter      RETURN      Next field               ',
  464. 'Del        DELETE      Delete character         ',
  465. 'Ctrl-Y     CTRLY       Delete characters to end ',
  466. '+          SET FLAG    Select multiple choice   ',
  467. '-          CLEAR FLAG  Clear multiple choice    ',
  468. 'Esc        ESCAPE      Return to MAIN MENU      '
  469. );
  470.  
  471. Var
  472.   Row : Byte;
  473.   TC  : Char;
  474. Begin
  475.   MakeWindow(5,1,20,50,ReverseAtt,ReverseAtt,DoubleBrdr,aWindow);
  476.   TitleWindow(Top,Right,' Editing Keys ');
  477.   TitleWindow(Bottom,Right,' Press Esc to continue ');
  478.   For Row := 6 to 23 Do QWrite(Row,2,ReverseAtt,Help[Row]);
  479.   GotoRC(24,48);
  480.   Repeat
  481.     TC := ReadKey;
  482.   Until TC = Escape;
  483.   RemoveWindow;
  484. End;
  485.  
  486. Function ReadChar : Char;
  487. Var
  488.   CH : Char;
  489. Begin                                                   { Function ReadChar }
  490.   ReadKb(ExtKey, CH);                  { read character                     }
  491.   If ExtKey Then                       { check for extened scan code        }
  492.   Begin
  493.     Case CH Of
  494.       #75 : CH := CursorLeft;          { Left-Arrow Key                     }
  495.       #77 : CH := CursorRight;         { Right-Arrow Key                    }
  496.       #72 : CH := CursorUp;            { Up-Arrow Key                       }
  497.       #80 : CH := CursorDown;          { Down-Arrow Key                     }
  498.       #73 : CH := PageUp;              { Page Up Key                        }
  499.       #81 : CH := PageDown;            { Page Down Key                      }
  500.       #71 : CH := CursorHome;          { Home-arrow key                     }
  501.       #79 : CH := CursorEnd;           { End-arrow key                      }
  502.       #83 : CH := DelKey;              { Delete key                         }
  503.       #59 : Begin
  504.               ShowEditHelp;            { F1 = Help Key                      }
  505.               CH := #0;
  506.             End;
  507.       Else  CH := #0;                  { invalid key                        }
  508.     End;                                                   { case statement }
  509.     If CH = #9  Then CH := TabKey;
  510.   End;
  511.   ReadChar := CH;
  512. End;                                                    { Function ReadChar }
  513.  
  514. Function ConstStr(C : Char; N : Byte) : String;
  515. Var
  516.   S : String;
  517. Begin
  518.   If N < 0 Then  N := 0;
  519.   S[0] := Chr(N);
  520.   FillChar(S[1], N, C);
  521.   ConstStr := S;
  522. End;
  523.  
  524. Function AskStr(Var S:String;Term:CharSet;L,X,Y:Byte;Var TC:Char):String;
  525. Const
  526.   Next : CharSet = [Return,CursorUp,CursorDown,PageUp,PageDown,Escape];
  527. Var
  528.   P    : Byte;    { Cursor Position }
  529.   Ch   : Char;    { Key Pressed }
  530.   Temp : String;
  531. Begin
  532.   CursorOn;
  533.   If S = '0' Then S[0] := #0;
  534.   Temp:=ConstStr(Filler,L-Length(S));
  535.   Temp := AddStrings(S,Temp);
  536.   QWrite(Y,X,ReverseAtt,Temp);
  537.   P := 0;
  538.   If Not UpperCase Then P := Length(S);
  539.   Repeat
  540.     GoToRC(Y,X+P);
  541.     Ch := ReadChar;
  542.     If UpperCase Then CH := UpCase(CH);
  543.     If (CH In Term) Then
  544.     Begin
  545.       If P < L Then
  546.       Begin
  547.         If Length(S) = L Then Delete(S, L, 1);
  548.         Inc(P);
  549.         Insert(CH, S, P);
  550.         Write(Copy(S, P, L));
  551.         If AutoWrap AND (P = L) Then Ch := Return;
  552.       End
  553.       Else If Not(AutoWrap) Then Beep;
  554.     End
  555.     Else
  556.     Case CH Of
  557.         ^H, #127 : If P > 0 Then      { Backspace key }
  558.                    Begin
  559.                      Delete(S, P, 1);
  560.                      Write(^H, Copy(S, P, L), Filler);
  561.                      Dec(P);
  562.                    End
  563.                    Else Beep;
  564.           DelKey : If P < Length(S) Then
  565.                    Begin
  566.                      Delete(S, Succ(P), 1);
  567.                      Write(Copy(S, Succ(P), L), Filler);
  568.                    End;
  569.       CursorLeft : If P > 0 Then Dec(P) { NON-destructive }
  570.                    Else Beep;
  571.       CursorRight: If P < Length(S) Then Inc(P) { NON-destructive }
  572.                    Else Beep;
  573.       CursorHome : P := 0;
  574.        CursorEnd : P := Length(S);
  575.               ^Y : Begin { Delete from current cursor position to end of field }
  576.                      Write(ConstStr(Filler, Length(S)-P));
  577.                      Delete(S, Succ(P), L);
  578.                    End;
  579.     End;
  580.   Until CH In Next;
  581.   P := Length(S);
  582.   QAttr(Y,X,1,L,NormalAtt);
  583.   Qfill(Y,X+P,1,L-P,NormalAtt,' ');
  584.   AskStr := S;
  585.   TC := CH;
  586.   CursorOff;
  587. End;
  588.  
  589. Function SelectString(Var Param : String; Len, X, Y : Byte) : Char;
  590. Var
  591.   Temp : String;
  592.   TC : Char;
  593. Begin
  594.   Temp := Param;
  595.   Temp := AskStr(Temp, [#32..#126], Len, X, Y, TC);
  596.   Param := Temp;
  597.   SelectString := TC;
  598. End;                                                         { SelectString }
  599.  
  600. Function SelectBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;
  601. Var
  602.   TC    : Char;
  603.   Temp  : String;
  604.   Value : Byte;
  605. Begin
  606.   Value := Param;
  607.   Temp := BooleanToString(Value,IfTrue,IfFalse);
  608.   UpperCase := True;
  609.   Temp := AskStr(Temp,[IfTrue,IfFalse],1,X,Y,TC);
  610.   If Length(Temp) =  0 Then
  611.   Begin
  612.     Param := 0;
  613.     QWrite(Y,X,NormalAtt,BooleanToString(Param,IfTrue,Iffalse));
  614.   End
  615.   Else
  616.   Begin
  617.     If Temp = Filler  Then Param := 0;
  618.     If Temp = IfTrue  Then Param := 1;
  619.     If Temp = IfFalse Then Param := 2;
  620.   End;
  621.   UpperCase := False;
  622.   SelectBoolean := TC;
  623. End;
  624.  
  625. Function SelectLongInt(Var Param:LongInt;Lower,Upper:LongInt;Len,X,Y:Byte):Char;
  626. Var
  627.   Temp     : String;
  628.   P, Value : LongInt;
  629.   I        : Integer;
  630.   Err      : Boolean;
  631.   TC       : Char;
  632. Begin
  633.   Repeat
  634.     Err := False;
  635.     Str(Param, Temp);  { Add '-' to allow for negative numbers }
  636.     Temp := AskStr(Temp, ['0'..'9'], Len, X, Y, TC);
  637.     Val(Temp, P, I);
  638.     If length(Temp) = 0 Then Value := 0
  639.     Else If I = 0 Then Value := P
  640.          Else
  641.          Begin
  642.            Value := Param;
  643.            Beep;
  644.            Err := True;
  645.          End;
  646.     If (Not((Value >= Lower) And (Value <= Upper))) Then Beep;
  647.   Until (Value >= Lower) And (Value <= Upper) And (Not(Err));
  648.   Param := Value;
  649.   SelectLongInt := TC;
  650. End;                                                            { SelectWord }
  651.  
  652. Function SelectWord(Var Param:Word;Lower,Upper:Word;Len,X,Y:Byte):Char;
  653. Var
  654.   TC : Char;
  655.   WW,WL,WH : LongInt;
  656. Begin
  657.   WW := LongInt(Param);
  658.   WL := LongInt(Lower);
  659.   WH := LongInt(Upper);
  660.   TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  661.   Param := Word(WW);
  662.   SelectWord := TC;
  663. End;                                                            { SelectWord }
  664.  
  665. Function SelectByte(Var Param:Byte;Lower,Upper,Len,X,Y:Byte):Char;
  666. Var
  667.   TC : Char;
  668.   WW,WL,WH : LongInt;
  669. Begin
  670.   WW := LongInt(Param);
  671.   WL := LongInt(Lower);
  672.   WH := LongInt(Upper);
  673.   TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  674.   Param := Byte(WW);
  675.   SelectByte := TC;
  676. End;                                                         { SelectByte }
  677.  
  678. Function SelectInteger(Var Param:Integer;Lower,Upper:Integer;Len,X,Y:Byte):Char;
  679. Var
  680.   TC : Char;
  681.   WW,WL,WH : LongInt;
  682. Begin
  683.   WW := LongInt(Param);
  684.   WL := LongInt(Lower);
  685.   WH := LongInt(Upper);
  686.   TC := SelectLongInt(WW,WL,WH,Len,X,Y);
  687.   Param := Integer(WW);
  688.   SelectInteger := TC;
  689. End;                                                            { SelectWord }
  690.  
  691. Function SelectReal(Var Param : Real; Lower, Upper : Real; Len, X, Y : Word) : Char;
  692. Var
  693.   Temp : String;
  694.   P, Value : Real;
  695.   I : Word;
  696.   Err : Boolean;
  697.   TC : Char;
  698. Begin
  699.   Repeat
  700.     Err := False;
  701.     Temp := RealToString(Param);
  702.                          { Add 'E' to allow for exponential notation }
  703.     Temp := AskStr(Temp, ['0'..'9', '.','-'], Len, X, Y, TC);
  704.     Val(Temp, P, I);
  705.     If Length(Temp) = 0 Then Value := 0.0
  706.     Else If I = 0 Then Value := P
  707.          Else
  708.          Begin
  709.            Value := Param;
  710.            Beep;
  711.            Err := True;
  712.          End;
  713.      If (Not((Value >= Lower) And (Value <= Upper))) Then Beep;
  714.   Until (Value >= Lower) And (Value <= Upper) And (Not(Err));
  715.   Param := Value;
  716.   SelectReal := TC;
  717. End;                                                           { SelectReal }
  718.  
  719. Function PhoneToString(Param : Phone) : String;
  720. Var
  721.   AA,XX,NN : String;
  722. Begin
  723.   AA := LeftPad_Word(Param.Area,3);
  724.   XX := LeftPad_Word(Param.XChange,3);
  725.   NN := LeftPad_Word(Param.Number,4);
  726.   PhoneToString := '('+ AA +') '+XX+'-'+NN;
  727. End;
  728.  
  729. Function SelectPhone(Var Param : Phone; Col,Row: Byte) : Char;
  730. Var
  731.   Temp : String;
  732.   TC   : Char;
  733.   Wrap : Boolean;
  734. Begin
  735.   Wrap := AutoWrap;
  736.   AutoWrap := True;
  737.   TC := SelectWord(Param.Area,0,999,3,Col+1,Row);
  738.   TC := SelectWord(Param.XChange,0,999,3,Col+6,Row);
  739.   AutoWrap := False;
  740.   TC := SelectWord(Param.Number,0,9999,4,Col+10,Row);
  741.   QWrite(Row,Col,NormalAtt,PhoneToString(Param));
  742.   AutoWrap := Wrap;
  743.   SelectPhone := TC;
  744. End;
  745.  
  746. Function TimeToString(Param : Time) : String;
  747. Var
  748.   HH,MM : String;
  749. Begin
  750.   HH := LeftPad_Byte(Param.Hour,2);
  751.   MM := LeftPad_Byte(Param.Minute,2);
  752.   TimeToString := HH + ':' + MM;
  753. End;
  754.  
  755. Function SelectTime(Var Param : Time; Col,Row: Byte) : Char;
  756. Var
  757.   Temp : String;
  758.   TC   : Char;
  759.   Wrap : Boolean;
  760. Begin
  761.   Wrap := AutoWrap;
  762.   AutoWrap := True;
  763.   TC := SelectByte(Param.Hour,0,24,2,Col,Row);
  764.   AutoWrap := False;
  765.   TC := SelectByte(Param.Minute,0,59,2,Col+3,Row);
  766.   QWrite(Row,Col,NormalAtt,TimeToString(Param));
  767.   AutoWrap := Wrap;
  768.   SelectTime := TC;
  769. End;
  770.  
  771. Procedure SetBit(Var Param: Byte;BitNum : Byte);
  772. Begin
  773.   Param := Param OR (1 Shl BitNum);
  774. End;
  775.  
  776. Procedure ClearBit(Var Param: Byte;BitNum : Byte);
  777. Begin
  778.   Param := Param AND Not (1 Shl BitNum);
  779. End;
  780.  
  781. Function Power(Pos : Byte) : Byte;
  782. { Returns Power = 2 ^ Pos }
  783. Begin
  784.   Power := 1 Shl Pred(Pos);
  785. End;
  786.  
  787. Procedure ShowMultipleChoice(Param,Bit:Byte;RowOffset,ColOffset:ShortInt);
  788. Const
  789.   Mark  = #251; {'√'}
  790.   Space = #32;  {' '}
  791. Begin
  792.   If Param AND Power(Bit) > 0
  793.      Then QWrite(Bit+RowOffset,ColOffSet,NormalAtt,Mark)
  794.      Else QWrite(Bit+RowOffset,ColOffSet,NormalAtt,Space);
  795. End;
  796.  
  797. Function SelectMultiple(Var Param:Byte;From,Limit,X,Y:ShortInt):Char;
  798. Const
  799.   Len    : Byte = 3; { length of reverse video }
  800.   Next   : CharSet = [PageDown,PageUp,Escape];
  801. Var
  802.   TC     : Char;
  803.   Choice,
  804.   J      : Byte;
  805.   Fin    : Boolean;
  806.   YOffset: Byte;
  807.   XOffset: Byte;
  808. Begin
  809.   CursorOn;
  810.   Fin := False; Choice := From;
  811.   YOffset:=Y;            {display stored values}
  812.   XOffset:=X;
  813.   Repeat
  814.     GotoRC(Choice+YOffset,XOffSet);
  815.     QAttr(Choice+YOffset,Pred(XOffSet),1,Len,ReverseAtt);
  816.     TC := ReadChar;
  817.     Case TC Of
  818.       CursorDown,
  819.       Return:     Begin
  820.                     QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
  821.                     If Choice = Limit Then Fin := True
  822.                     Else Inc(Choice);
  823.                   End;
  824.       CursorUp:   Begin
  825.                     QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
  826.                     If Choice = From Then Fin := True
  827.                     Else Dec(Choice);
  828.                   End;
  829.       PlusKey:    Begin
  830.                     SetBit(Param,Pred(Choice));
  831.                     ShowMultipleChoice(Param,Choice,YOffset,XOffSet);
  832.                     QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
  833.                   End;
  834.       MinusKey:   Begin
  835.                     ClearBit(Param,Pred(Choice));
  836.                     ShowMultipleChoice(Param,Choice,YOffset,XOffSet);
  837.                     QAttr(Choice+YOffset,Pred(XOffSet),1,Len,NormalAtt);
  838.                   End;
  839.     End;
  840.   Until Fin OR (TC in Next);
  841.   CursorOff;
  842.   SelectMultiple := TC;
  843. End;
  844.  
  845. Function DateToYear(Julian: Date) : Integer;
  846.   { Get Year from Date }
  847. Var
  848.   Juliian : Date;
  849.   Day,Month,Year : Integer;
  850. Begin
  851.   DateToDMY(Julian,Day,Month,Year);
  852.   DateToYear := Year;
  853. End;
  854.  
  855. Function DateToMonth(Julian: Date) : Integer;
  856.   { Get Month from Date }
  857. Var
  858.   Juliian : Date;
  859.   Day,Month,Year : Integer;
  860. Begin
  861.   DateToDMY(Julian,Day,Month,Year);
  862.   DateToMonth := Month;
  863. End;
  864.  
  865. Function DateToDay(Julian: Date) : Integer;
  866.   { Get Day from Date }
  867. Var
  868.   Juliian : Date;
  869.   Day,Month,Year : Integer;
  870. Begin
  871.   DateToDMY(Julian,Day,Month,Year);
  872.   DateToDay := Day;
  873. End;
  874.  
  875. Function DateToStr(Date1:Date):Str8;
  876. Var
  877.   Temp : Str8;
  878.   MM,DD,YY : String;
  879.   Day,Month,Year : Integer;
  880. Begin
  881.   DateToDMY(Date1,Day,Month,Year);
  882.   Dec(Year,1900);
  883.   MM := LeftPad_Integer(Month,2);
  884.   DD := LeftPad_Integer(Day,2);
  885.   YY := LeftPad_Integer(Year,2);
  886.   Temp := MM+'/'+DD+'/'+YY;
  887.   DateToStr := Temp;
  888. End;
  889.  
  890. Procedure DisplayDate(Date1:Date;X,Y:Byte);
  891. Var
  892.   Temp : Str8;
  893. Begin
  894.   Temp:= DateToStr(Date1);
  895.   QWrite(Y,X,NormalAtt,Temp);
  896. End;
  897.  
  898. Procedure DisplayNewDate(Date1:Date;X,Y:Byte);
  899. Var
  900.   Temp : Str8;
  901. Begin
  902.   Temp:= DateToStr(Date1);
  903.   Temp[0] := Chr(5);        { display first 5 letters }
  904.   QWrite(Y,X,NormalAtt,Temp);
  905. End;
  906.  
  907. Function SelectDate(Var Date1:Date;X,Y:Byte): Char;
  908. Var
  909.   Ok : Boolean;
  910.   Ch : Char;
  911.   Wrap : Boolean;
  912.   Day,Month,Year : Integer;
  913. Begin
  914.   Wrap := AutoWrap; { Save current value of AutoWrap }
  915.   UpperCase := True;
  916.   DateToDMY(Date1,Day,Month,Year);
  917.   Repeat
  918.     Ok := True;
  919.     DisplayDate(Date1,X,Y);
  920.     Dec(Year,1900);
  921.     AutoWrap := True;
  922.     Ch := SelectInteger(month,1,12,2,X,Y);
  923.     Ch := SelectInteger(day,1,31,2,x+3,y);
  924.     AutoWrap := False;
  925.     Ch := SelectInteger(year,1,99,2,x+6,y);
  926.     Inc(Year,1900);
  927.     Ok := ValidDate(Day,Month,Year);
  928.   Until OK;
  929.   DMYToDate(Day,Month,Year,Date1);
  930.   DisplayDate(Date1,X,Y);
  931.   Selectdate := Ch;
  932.   UpperCase := False;
  933.   AutoWrap := Wrap; { Reset AutoWrap }
  934. End;
  935.  
  936. Function DaysBtWn(Date1,Date2:Date):Word;
  937. Begin
  938.   DaysBtWn  := Date2 - Date1;
  939. End;
  940.  
  941. Function AddDays(Date1:Date;Num:Integer):Date;
  942. Begin
  943.   AddDays := BumpDate(Date1,Num,0,0);
  944. End;
  945.  
  946. Function AddMonths(Date1:Date;Num:Integer):Date;
  947. Begin
  948.   AddMonths := BumpDate(Date1,0,Num,0);
  949. End;
  950.  
  951. Function ByteInRange(Var Param : Byte; Test : ByteSet):Boolean;
  952. Var
  953.   Temp : Boolean;
  954. Begin
  955.   Temp := True;
  956.   If Not(Param In Test) Then
  957.   Begin
  958.     Param := 0;
  959.     Beep;
  960.     Temp := False;
  961.   End;
  962.   ByteInRange := Temp;
  963. End;
  964.  
  965. Function WordInRange(Var Param : Word; Min,Max : Word):Boolean;
  966. Var
  967.   Temp : Boolean;
  968. Begin
  969.   Temp := True;
  970.   If Param <> 0 Then
  971.   Begin
  972.     If (Param < Min) OR (Param > Max) Then
  973.     Begin
  974.       Param := 0;
  975.       Beep;
  976.       Temp := False;
  977.     End;
  978.   End;
  979.   WordInRange := Temp;
  980. End;
  981.  
  982. Function SSNToString(Param : SSN) : String;
  983. Var
  984.   Temp : String;
  985.   SS   : String;
  986. Begin
  987.   SS := LeftPad_Word(Param.First,3);
  988.   Temp := SS + '-';
  989.  
  990.   SS := LeftPad_Word(Param.Middle,2);
  991.   Temp := Temp + SS + '-';
  992.  
  993.   SS := LeftPad_Word(Param.Last,4);
  994.   Temp := Temp + SS;
  995.  
  996.   SSNToString := Temp;
  997. End;
  998.  
  999. Function SelectSSN(Var Param : SSN; X, Y : Byte):Char;
  1000. Var
  1001.   TC : Char;
  1002.   Wrap : Boolean;
  1003. Begin
  1004.   Wrap := AutoWrap;
  1005.   AutoWrap := True;
  1006.   TC := SelectWord(Param.First,0,999,3,X  ,Y);
  1007.   TC := SelectWord(Param.Middle,0,99,2,X+4,Y);
  1008.   AutoWrap := False;
  1009.   TC := SelectWord(Param.Last,0,9999,4,X+7,Y);
  1010.   QWrite(Y,X,NormalAtt,SSNToString(Param));
  1011.   AutoWrap := Wrap;
  1012.   SelectSSN := TC;
  1013. End;
  1014.  
  1015. Function ColorSelect(RR,CC,DR,DC : Byte) : Byte;
  1016. { No Error checking is done, so make sure RR is in [1..25]
  1017.   and CC is in [1..80] }
  1018. Const
  1019.   Clear : Char = #4;
  1020.   Flag  : Char = #15;
  1021. Var
  1022.   Row,
  1023.   Col : Byte;
  1024.   Att : Integer;
  1025.   TC  : Char;
  1026.   TLimit,BLimit,Rlimit,LLimit : Byte;
  1027.  
  1028. Begin
  1029.   TLimit := RR + 1;
  1030.   BLimit := RR + 8;
  1031.   LLimit := CC + 1;
  1032.   RLimit := CC + 16;
  1033.  
  1034.   MakeWindow(RR,CC,10,18,NormalAtt,NormalAtt,SingleBrdr,aWindow);
  1035.   TitleWindow(Top,Center,' Colors ');
  1036.   For Row := 0 to 7 Do For Col := 0 to 15 Do
  1037.   Begin
  1038.     Att := Attr(Col,Row);
  1039.     QFill(RR + Row + 1,CC + Col + 1,1,1,Att,Clear);
  1040.   End;
  1041.  
  1042.   Row := RR + DR; { DR = Default Row }
  1043.   Col := CC + DC; { DC = Default Column }
  1044.   Repeat
  1045.     GotoRC(Row,Col);
  1046.     QFill(Row,Col,1,1,-1,Flag);
  1047.     TC := ReadChar;
  1048.     QFill(Row,Col,1,1,-1,Clear);
  1049.     Case TC Of
  1050.       CursorDown: Begin
  1051.                     If Row = BLimit Then Row := Tlimit
  1052.                     Else Inc(Row);
  1053.                   End;
  1054.       CursorUp:   Begin
  1055.                     If Row = TLimit Then Row := BLimit
  1056.                     Else Dec(Row);
  1057.                   End;
  1058.      CursorRight: Begin
  1059.                     If Col = RLimit Then Col := LLimit
  1060.                     Else Inc(Col);
  1061.                   End;
  1062.       CursorLeft: Begin
  1063.                     If Col = LLimit Then Col := RLimit
  1064.                     Else Dec(Col);
  1065.                   End;
  1066.     End;
  1067.   Until TC = Return;
  1068.   RemoveWindow;
  1069. {
  1070.   Note:
  1071.     ForeGround := Col - CC - 1
  1072.     BackGround := Row - RR - 1
  1073. }
  1074.   ColorSelect := Attr(Col - CC - 1,Row - RR - 1);
  1075. End;
  1076.  
  1077. Procedure Wait(On : Boolean);
  1078. Begin
  1079.   If On Then
  1080.   Begin
  1081.     MakeWindow(1,70,3,8,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
  1082.     QWrite(2,71,ReverseAtt+Blink,' WAIT ');
  1083.   End
  1084.   Else RemoveWindow;
  1085. End;
  1086.  
  1087. Function AreYouSure : Boolean;
  1088. Var
  1089.   TC  : Char;
  1090.   Yes : Byte;
  1091. Begin
  1092.   MakeWindow(10,30,3,19,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
  1093.   QWrite(11,31,ReverseAtt,' Are You Sure? ');
  1094.   Yes := 2;
  1095.   TC := SelectBoolean(Yes,'Y','N',46,11);
  1096.   Case Yes of
  1097.     0,2 : AreYouSure := False;
  1098.     1   : AreYouSure := True;
  1099.   End;
  1100.   If TC = Escape Then AreYouSure := False;
  1101.   RemoveWindow;
  1102. End;
  1103.  
  1104. Function SureToDelete(ID : Word) : Boolean;
  1105. Var
  1106.   TC  : Char;
  1107.   Yes : Byte;
  1108.   TS  : String[5];
  1109. Begin
  1110.   Str(ID:5,TS);
  1111.   MakeWindow(10,20,4,41,ReverseAtt,ReverseAtt,SingleBrdr,aWindow);
  1112.   QWrite(11,21,ReverseAtt,' You are about to delete record: ');
  1113.   QWrite(11,54,ReverseAtt,TS);
  1114.   QWrite(12,21,ReverseAtt,' Are You Sure? ');
  1115.   Yes := 2;
  1116.   TC := SelectBoolean(Yes,'Y','N',36,12);
  1117.   Case Yes of
  1118.     0,2 : SureToDelete := False;
  1119.     1   : SureToDelete := True;
  1120.   End;
  1121.   If TC = Escape Then SureToDelete := False;
  1122.   RemoveWindow;
  1123. End;
  1124.  
  1125. Function FileExist(FileName : String) : Boolean;
  1126. Var
  1127.    F    : File;
  1128.    fAttr : Word;
  1129. Begin
  1130.    Assign(F,FileName);
  1131.    GetFAttr(f,fAttr);
  1132.    FileExist := (fAttr <> 0) And ((fAttr AND Directory) = 0)
  1133. End; { FileExist }
  1134.  
  1135. Function DirExist(DirName : String) : Boolean;
  1136. Var
  1137.    F    : File;
  1138.    fAttr : Word;
  1139. Begin
  1140.    Assign(F,DirName);
  1141.    GetFAttr(f,fAttr);
  1142.    DirExist := (fAttr AND Directory) <> 0
  1143. End; { DirExist }
  1144.  
  1145. Function CopyFile(Source, Dest : String) : Word;
  1146. { Copies a file to another file }
  1147. Type
  1148.   FileBuffer = array[1..65521] of byte;
  1149. Var
  1150.   Buf              : ^Byte;
  1151.   InF,OutF         : File;
  1152.   ErrorCode,
  1153.   BlocksRead,
  1154.   BlocksWritten    : Word;
  1155.   Time             : LongInt;
  1156.   BufferSize       : Word;
  1157. Begin
  1158.   BufferSize := SizeOf(FileBuffer);
  1159.   If (BufferSize > MaxAvail) Then BufferSize := MaxAvail;
  1160.   GetMem(Buf,BufferSize); { allocate memory for the buffer }
  1161.   Assign(InF,Source);
  1162.   Reset(InF,1);           { open the source file }
  1163.   ErrorCode := IOResult;
  1164.   GetFTime(InF,Time);     { get time/date stamp from source file }
  1165.   If ErrorCode = 0 then
  1166.   Begin
  1167.     Assign(OutF,Dest);
  1168.     Rewrite(OutF,1);      { Create destination file }
  1169.     ErrorCode := IOResult;
  1170.     { copy loop }
  1171.     If ErrorCode = 0 Then
  1172.     Begin
  1173.       Repeat
  1174.         BlockRead(InF,Buf^,BufferSize,BlocksRead);      { read a buffer full from source }
  1175.         BlockWrite(OutF,Buf^,BlocksRead,BlocksWritten); { write it to destintion }
  1176.         If BlocksWritten < BlocksRead Then ErrorCode := 81; { Insufficient disk space }
  1177.       Until ((ErrorCode <> 0) OR (BlocksRead < BufferSize));
  1178.       SetFTime(OutF,Time);     { Set time/date stamp of dest to that of source }
  1179.       Close(OutF); { Close destination file }
  1180.       If ErrorCode <> 0 Then Erase(OutF); { Copy was unsuccessful }
  1181.     End;
  1182.     Close(InF);       { close source file }
  1183.   End;
  1184.   CopyFile := ErrorCode;
  1185.   FreeMem(Buf,BufferSize); { deallocate heap space for buffer }
  1186. End; { CopyFile }
  1187.  
  1188. Begin { program body }
  1189.   NormalAtt  := 15;
  1190.   ReverseAtt := 112;
  1191. End.
  1192.